if not (MacroBufP^[i] = cr) or (MacroBufP^[i] = '|') then
cLine := concat(cLine, MacroBufP^[i]);
until (i >= EndMacros) or (MacroBufP^[i] = cr) or (MacroBufP^[i] = '|') or (count > 60);
while (length(cLine) > 1) and (cLine[1] = ' ') do
delete(cLine, 1, 1);
CurrentLine := concat(crStr, '<<', cLine, '>>');
end;
procedure LTMacroError (str: str255);
{Report load-time errors}
var
str2: str255;
i, count: integer;
line: string;
begin
if token = DoneT then
exit(LTMacroError);
if TopOfStack > 0 then
DeallocateStrings2(1, TopOfStack);
PutError(concat(str, ' in line ', long2str(MacroLineNumber), ' of macro file.', CurrentLine));
Token := DoneT;
end;
procedure LookupIdentifier;
var
i: integer;
begin
with MacrosP^ do
for i := 1 to nSymbols do begin
if TokenSymbol = SymbolTable[i].symbol then
with SymbolTable[i] do begin
token := tType;
MacroCommand := cType;
TokenLoc := loc;
SymbolTableLoc := i;
exit(LookupIdentifier);
end;
end; {for}
token := UnknownIdentifier;
end;
procedure GetToken;
var
c: char;
SymbolLength: integer;
begin
if token = DoneT then
exit(GetToken);
SavePC := PC;
SaveToken := token;
while not (MacroBufP^[pc] in ['a'..'z', '0'..'9', '(', ')', ',', '''', '+', '-', '*', '/', ':', ';', '=', '.', '>', '<', '[', ']', '|']) do begin {skip white space}
if MacroBufP^[pc] = cr then
MacroBufP^[pc] := '|'
else
pc := pc + 1;
if pc > EndMacros then begin
Token := DoneT;
exit(GetToken);
end;
end;
c := MacroBufP^[pc];
case c of
'a'..'z': begin
TokenSymbol := BlankSymbol;
SymbolLength := 0;
while MacroBufP^[pc] in ['a'..'z', '0'..'9'] do begin
SymbolLength := SymbolLength + 1;
if SymbolLength <= SymbolSize then
TokenSymbol[SymbolLength] := MacroBufP^[pc];
pc := pc + 1;
if pc > EndMacros then begin
Token := DoneT;
exit(GetToken);
end;
end;
Token := identifier;
LookupIdentifier;
exit(GetToken);
end;
'0'..'9', '.': begin
TokenStr := '';
while MacroBufP^[pc] in ['0'..'9', '.'] do begin
TokenStr := Concat(TokenStr, c);
pc := pc + 1;
c := MacroBufP^[pc];
if pc > EndMacros then begin
Token := DoneT;
exit(GetToken);
end;
end;
Token := NumericLiteral;
if MacroBufP^[pc] in ['a'..'z'] then
LTMacroError('Operator or delimiter expected');
exit(GetToken);
end;
'(': begin
Token := LeftParen;
pc := pc + 1;
end;
')': begin
Token := RightParen;
pc := pc + 1;
end;
'[': begin
Token := LeftBracket;
pc := pc + 1;
end;
']': begin
Token := RightBracket;
pc := pc + 1;
end;
',': begin
Token := comma;
pc := pc + 1;
end;
':':
if MacroBufP^[pc + 1] = '=' then begin
Token := AssignOp;
pc := pc + 2;
end
else begin
Token := colon;
pc := pc + 1;
end;
';': begin
Token := SemiColon;
pc := pc + 1;
end;
'+': begin
Token := PlusOp;
pc := pc + 1;
end;
'-': begin
Token := MinusOp;
pc := pc + 1;
end;
'*': begin
Token := MulOp;
pc := pc + 1;
end;
'/': begin
Token := DivOp;
pc := pc + 1;
end;
'''': begin
TokenStr := '';
pc := pc + 1;
while MacroBufP^[pc] <> '''' do begin
TokenStr := Concat(TokenStr, MacroBufP^[pc]);
pc := pc + 1;
if pc > EndMacros then begin
Token := DoneT;
exit(GetToken);
end;
end;
pc := pc + 1;
Token := StringLiteral;
end;
'=': begin
Token := eqOp;
pc := pc + 1;
end;
'<': begin
pc := pc + 1;
if MacroBufP^[pc] = '>' then begin
token := neOp;
pc := pc + 1;
end
else if MacroBufP^[pc] = '=' then begin
token := leOp;
pc := pc + 1;
end
else
token := ltOp;
end;
'>': begin
pc := pc + 1;
if MacroBufP^[pc] = '=' then begin
token := geOp;
pc := pc + 1;
end
else
token := gtOp;
end;
'|': begin
Token := NewLineT;
MacroLineNumber := MacroLineNumber + 1;
StartOfLine := pc;
pc := pc + 1;
end;
otherwise begin
token := NullT;
beep;
end;
end; {case}
end;
procedure AddProcedure;
begin
GetToken;
if token <> UnknownIdentifier then begin
LTMacroError('Procedure name missing or previously defined');
exit(AddProcedure);
end;
if nSymbols >= MaxSymbols then begin
LTMacroError('Symbol table overflow');
exit(AddProcedure);
end;
nSymbols := nSymbols + 1;
nProcedures := nProcedures + 1;
with MacrosP^, MacrosP^.SymbolTable[nSymbols] do begin
symbol := TokenSymbol;
tType := procedureT;
cType := NullC;
if MacroBufP^[pc] = ';' then
pc := pc + 1;
loc := pc2 + 1;
end;
end;
procedure AddFunction;
begin
GetToken;
if token <> UnknownIdentifier then begin
LTMacroError('Function name missing or previously defined');
exit(AddFunction);
end;
if nSymbols >= MaxSymbols then begin
LTMacroError('Symbol table overflow');
exit(AddFunction);
end;
nSymbols := nSymbols + 1;
nProcedures := nProcedures + 1;
with MacrosP^, MacrosP^.SymbolTable[nSymbols] do begin
symbol := TokenSymbol;
tType := UserFunctionT;
cType := NullC;
loc := pc2 + 1;
end;
end;
procedure AddIdentifier;
begin
if nSymbols >= MaxSymbols then begin
LTMacroError('Symbol table overflow');
exit(AddIdentifier);
end;
nSymbols := nSymbols + 1;
with MacrosP^, MacrosP^.SymbolTable[nSymbols] do begin
symbol := TokenSymbol;
tType := Identifier;
cType := NullC;
loc := pc2;
end;
end;
procedure GetGDToken;
begin
GetToken;
while token = NewLineT do begin
MacrosP^.macros[pc2] := chr(ord(token));
pc2 := pc2 + 1;
GetToken;
end;
end;
procedure DoGlobalDeclaration;
var
SaveStackLoc, StackLoc: integer;
begin
SaveStackLoc := TopOfStack;
while (token = UnknownIdentifier) or (token = Identifier) do begin
if Token = UnknownIdentifier then begin
AddIdentifier;
SymbolTableLoc := nSymbols;
token := identifier;
end;
if TopOfStack >= MaxMacroStackSize then begin
LTMacroError(StackOverflow);
exit(DoGlobalDeclaration);
end;
TopOfStack := TopOfStack + 1;
nGlobals := nGlobals + 1;
with MacrosP^.stack[TopOfStack] do begin
SymbolTableIndex := SymbolTableLoc;
value := 0.0;
StringH := nil;
end;
GetGDToken;
if token = comma then
GetGDToken;
if (token = FunctionT) or (token = StringFunctionT) or (token = CommandT) or (token = ArrayT) then begin
LTMacroError('Predefined identifier');
exit(DoGlobalDeclaration);
end;
end; {while}
if token <> colon then
LTMacroError('":" expected');
GetGDToken;
if (token <> IntegerT) and (token <> RealT) and (token <> BooleanT) and (token <> StringT) then
LTMacroError('"integer", "real", "boolean" or "string" expected');
for StackLoc := SaveStackLoc + 1 to TopOfStack do
with macrosP^.stack[StackLoc] do
case token of
IntegerT:
vType := IntVar;
RealT:
vType := RealVar;
BooleanT:
vType := BooleanVar;
StringT: begin
vType := StringVar;
StringH := str255H(NewHandle(SizeOf(str255)));
if StringH = nil then begin
LTMacroError('Out of memory');
Token := DoneT
end
else
StringH^^ := 'Global String';
end;
otherwise
end;
GetGDToken;
if Token = SemiColon then
GetGDToken;
end;
procedure PutTokenBack2;
begin
if token <> DoneT then begin
pc := SavePC;
token := SaveToken;
end;
end;
procedure DoGlobalDeclarations;
begin
GetGDToken;
if (token = FunctionT) or (token = StringFunctionT) or (token = CommandT) or (token = ArrayT) then begin
LTMacroError('Predefined identifier');
exit(DoGlobalDeclarations);
end;
while ((token = UnknownIdentifier) or (token = Identifier)) and (Token <> DoneT) do
DoGlobalDeclaration;
PutTokenBack2;
end;
function PreScan1: boolean;
{Converts the macro file to lowercase and removes comments.}
var
inString, inComment: boolean;
c: char;
i, StartComment, number: integer;
line: string;
function LineNumber: integer;
var
i, n: integer;
begin
n := 1;
for i := 0 to pc do
if MacroBufP^[i] = cr then begin
StartOfLine := i;
n := n + 1;
end;
LineNumber := n;
end;
begin
PreScan1 := false;
inString := false;
inComment := false;
for i := 0 to EndMacros do begin
c := MacroBufP^[i];
if inString and (c = cr) then begin
pc := i - 1;
number := LineNumber;
line := CurrentLine;
PutError(StringOf('The quoted string in line ', number, ' of the macro file is not terminated.', line));
exit(PreScan1);
end;
if (not InString) and (c = '{') then begin
InComment := true;
StartComment := i;
end;
if inComment then begin
if (c = '{') and (i <> StartComment) then begin
PutError(concat('Comments cannot be nested.', CurrentLine));
exit(PreScan1);
end;
if c = '}' then
inComment := false;
if c <> cr then
MacroBufP^[i] := ' ';
end
else begin
if (c = '‘') or (c = '`') then begin
pc := i;
number := LineNumber;
line := CurrentLine;
PutError(StringOf('Bad quote("‘" or "`") in line ', number, ' of macro file.', line));
exit(PreScan1);
end;
if c = '''' then
inString := not inString;
if (c >= 'A') and (c <= 'Z') and not inString then
MacroBufP^[i] := chr(ord(c) + 32);
end;
end;
if inComment then begin
pc := StartComment;
number := LineNumber;
line := CurrentLine;
PutError(StringOf('The comment starting in line ', number, ' of the macro file is not terminated.', line))
end
else
PreScan1 := true;
end;
procedure StoreInteger (i: integer);
begin
with macrosP^ do begin
pc2 := pc2 + 1;
macros[pc2] := chr(band(bsr(i, 8), $ff));
pc2 := pc2 + 1;
macros[pc2] := chr(band(i, $ff));
end;
end;
procedure StoreReal (r: real);
type
bytes=packed array[1..4] of char;
var
vrec:record
case integer of
1: (rv: real);
2: (b: bytes)
end;
begin
{b := bytes(r);} {ppc-bug}
vrec.rv:=r;
with macrosP^,vrec do begin
pc2 := pc2 + 1;
macros[pc2] :=b[1];
pc2 := pc2 + 1;
macros[pc2] :=b[2];
pc2 := pc2 + 1;
macros[pc2] :=b[3];
pc2 := pc2 + 1;
macros[pc2] := b[4];
end;
end;
procedure StoreString;
var
i: integer;
begin
with macrosP^ do begin
for i := 1 to length(TokenStr) do begin
pc2 := pc2 + 1;
macros[pc2] := TokenStr[i];
end;
pc2 := pc2 + 1;
macros[pc2] := chr(0);
end;
end;
procedure AddMenuItem;
var
i, fkey: integer;
c, key: char;
begin
with MacrosP^ do begin
GetToken;
pc2 := pc2 + 1;
macros[pc2] := chr(ord(token));
if token <> StringLiteral then begin
LTMacroError('Macro command name not found');
exit(AddMenuItem);
end;
StoreString;
if nMacros < MaxMacros then begin
AppendMenu(SpecialMenuH, TokenStr);
nMacros := nMacros + 1
end
else
PutError('Too many macros.');
if macros[pc] = ';' then
pc := pc + 1;
MacroStart[nMacros] := pc2 + 1;
i := pos('[', TokenStr);
if i > 0 then begin {Assign a key to macro?}
i := i + 1;
key := TokenStr[i];
if (key >= 'A') and (key <= 'Z') then
key := chr(ord(key) + 32);
MacroKey[nMacros] := key;
if (key = 'f') and (TokenStr[i + 1] in ['1'..'9']) then begin {Function Key?}
